Computer Select (Limited Edition)/Computer Select.iso/pcc/v04n12/windoc.exe/GLOBCODE.BAS

BASIC Source File | 1991-11-01 | 11.6 KB | 474 lines

DefInt A-Z

Sub fullpath ()
If Right$(editpath, 1) <> "\" Then editpath = editpath + "\"
editfile = editpath + editfile
End Sub

Sub waitsecs (secs)
    start! = Timer
    While Timer < start! + secs
    temp = DoEvents()
    Wend
End Sub

Sub newfile ()
screen.mousepointer = 1


' Select Case Right$(editfile, 3)
' Case "sam"

RunProg$ = "C:\amipro\amipro.exe "
AppName$ = "Ami Pro"

' Case Else
' Screen.mousepointer = 1: Exit Sub
' End Select


If Not Loaded(AppName$) Then
T = Shell(RunProg$, 4)
Else
AppActivate (AppName$)
If IsIconic(LastWindowHandle) Then
T = PostMessage(LastWindowHandle, WM_SYSCOMMAND, SC_RESTORE, 0)
waitsecs 1
End If
End If
Quote$ = Chr$(34)
CR$ = Chr$(13)
NewCommand$ = "[new]"
If actions.Text1.LinkMode = NONE Then
actions.Text1.LinkTopic = "amipro|system"
actions.Text1.LinkMode = COLD
actions.Text1.LinkTimeOut = -1
End If
waitsecs 1
actions.Text1.LinkExecute NewCommand$
actions.Text1.LinkMode = NONE
Exit Sub
screen.mousepointer = 1
End Sub

Sub printfile ()
getfile
If editfile = "" Then Exit Sub
screen.mousepointer = 11
Select Case Right$(editfile, 3)
Case "sam"
RunProg$ = "C:\amipro\amipro.exe "
AppName$ = "Ami Pro"
Case "smm"
RunProg$ = "C:\amipro\amipro.exe "
AppName$ = "Ami Pro"
Case Else
screen.mousepointer = 1: Exit Sub
End Select
If Not Loaded(AppName$) Then
    X = Shell(RunProg$ + " /p " + editfile, 2)
Else
    AppActivate (AppName$)
        If IsIconic(LastWindowHandle) Then
        X = PostMessage(LastWindowHandle, WM_SYSCOMMAND, SC_RESTORE, 0)
        waitsecs 1
        End If
    SendKeys "%FO" + editfile + "~", TRUE
    '   waitsecs 1
    SendKeys "%WC", TRUE
    '   waitsecs 1
    SendKeys "%FP", TRUE
    '   waitsecs 1
    SendKeys "~", TRUE
End If
waitsecs 1
screen.mousepointer = 1
End Sub

Sub DeleteFile ()
getfile
If editfile = "" Then Exit Sub
boxtype = MB_OkCancel + MB_iconexclamation
msg$ = "Delete " + editfile + "?"
response = MsgBox(msg$, boxtype, "Delete File")

    Select Case response
    Case 1
     On Error GoTo notfound
     Kill editfile
     On Error GoTo 0
     DeleteRecord
    Case 2
      Exit Sub
    End Select
Exit Sub

notfound:
Resume Next

End Sub

Sub ExitDocMan ()
     CleanUp
     End
End Sub

Sub AddFileEntry ()
 'increment last record
 'build record
 lastrecord = lastrecord + 1
 recordvar.recordnum = lastrecord + 1
 recordvar.Description = OpenDM.Description.text
 recordvar.file = OpenDM.Text1(0).text
 recordvar.date = OpenDM.Text1(2).text
 recordvar.owner = OpenDM.Text1(1).text
 recordvar.key1 = OpenDM.Text1(4).text
 recordvar.key2 = OpenDM.Text1(5).text
 recordvar.key3 = OpenDM.Text1(6).text
 recordvar.key4 = OpenDM.Text1(7).text
' opendm.files.listindex = lastrecord - 1
 recordvar.title = OpenDM.Files.list(Listindex)
Put filenum, lastrecord, recordvar
addkeys
End Sub

Function fileopener (NameToUse$, Mode, recordlen) As Integer
'   opens a file in specified address mode
'   Arguements: Nametouse$ == valid filename
'               mode--file access mode
'               recordlen--length of one record
Const REPLACEFILE = 1, READFILE = 2, ADDTOFILE = 3
Const RANDOMFILE = 4, BINARYFILE = 5
OpenFileNum = FreeFile
On Error GoTo OPENERERROR
Select Case Mode
Case REPLACEFILE
Open NameToUse$ For Output As OpenFileNum
Case READFILE
Open NameToUse$ For Input As OpenFileNum
Case ADDTOFILE
Open NameToUse$ For Append As OpenFileNum
Case RANDOMFILE
Open NameToUse$ For Random As OpenFileNum Len = recordlen
lastrecord = LOF(OpenFileNum) \ Len(recordvar)
Case BINARYFILE
Open NameToUse$ For Binary As OpenFileNum
Case Else
Exit Function
End Select
fileopener = OpenFileNum
Exit Function

OPENERERROR:
action = FileErrors(Err, NameToUse$)
Select Case action
Case 0
Resume
Case Else
fileopener = 0
End
End Select
End Function

Function FileErrors (Errval As Integer, Filename As String) As Integer

'returns    0--resume               2--unrecoverable error
'           1--resume next          3--unrecognized error
msgtype = MB_iconexclamation + 2

Select Case Errval
    Case ERR_DEVICEUNAVAILABLE 'error 68
        msg$ = "Device unavailable "
    Case ERR_DISKNOTREADY
        msg$ = "Disk not ready"
    Case ERR_DEVICEIO
        msg$ = "Internal disk error."
    Case ERR_DISKFULL
        msg$ = "Disk full."
    Case ERR_BADFILENAMEORNUMBER
        msg$ = Filename + " is an illegal filename."
    Case err_PATH_FILEACCESSERROR, ERR_PATHNOTFOUND
        msg$ = "The path " + Filename + " doesn't exist."
    Case ERR_BADFILEMODE
        msg$ = "Can't open " + Filename + " for that kind of access."
    Case ERR_FILEALREADYOPEN
        msg$ = Filename + " already open."
    Case ERR_INPUTPASTENDOFFILE
        msg$ = Filename + " has a nonstandard end of file marker,"
        msg$ = msg$ + " or an attempt was made to read beyond"
        msg$ = msg$ + " the end of the file."
    Case ERR_FILENOTFOUND
        msg$ = Filename + " not found."
    Case Else
        msg$ = "File or disk error associated with " + Filename + "! Error code: " + Str$(Errval)
    End Select
    response = MsgBox(msg$, msgtype, "Disk Error")
    Select Case response
        Case IDOK, IDRETRY
            FileErrors = 0
        Case IDIGNORE
            FileErrors = 1
        Case IDCANCEL, IDABORT
            FileErrors = 2
        Case Else
            FileErrors = 3
        End Select
    End Function

Sub writechangedrecord ()
 If NewRecordFlag = TRUE Then Exit Sub
 recordvar.title = OpenDM.Files.list(wasrecordchanged)
 recordvar.Description = OpenDM.Description.text
 recordvar.key1 = OpenDM.Text1(4).text
 recordvar.key2 = OpenDM.Text1(5).text
 recordvar.key3 = OpenDM.Text1(6).text
 recordvar.key4 = OpenDM.Text1(7).text
 Put filenum, wasrecordchanged + 1, recordvar
 wasrecordchanged = -1
 addkeys
End Sub

Sub ReadSelectedRecord ()
If OpenDM.Files.Listindex < 0 Then Exit Sub
If (OpenDM.Files.Listindex + 1) <= lastrecord And lastrecord > 0 Then
 Get filenum, OpenDM.Files.Listindex + 1, recordvar
 OpenDM.Description.text = RTrim$(recordvar.Description)
 OpenDM.Text1(0).text = RTrim$(recordvar.file)
 OpenDM.Text1(2).text = RTrim$(recordvar.date)
 OpenDM.Text1(1).text = RTrim$(recordvar.owner)
 OpenDM.Text1(4).text = RTrim$(recordvar.key1)
 OpenDM.Text1(5).text = RTrim$(recordvar.key2)
 OpenDM.Text1(6).text = RTrim$(recordvar.key3)
 OpenDM.Text1(7).text = RTrim$(recordvar.key4)
 wasrecordchanged = -1
End If
End Sub

Sub DeleteRecord ()
Dim tempvar As RecordType
position = OpenDM.Files.Listindex + 1
For i = position To lastrecord - 1
Get filenum, i + 1, tempvar
tempvar.recordnum = i
Put filenum, i, tempvar
Next i
lastrecord = lastrecord - 1
If lastrecord = 0 Then clearfields
OpenDM.Files.RemoveItem position - 1
OpenDM.Files.Listindex = lastrecord - 1
OpenDM.Files.Refresh
End Sub

Sub CleanUp ()
    If wasrecordchanged > -1 Then
        writechangedrecord
    End If
NewFileName$ = "\vb\docman\DM.TMP"
modetouse = 4
recordcount = lastrecord
On Error GoTo cleanuperrs
cleanupfilenum = fileopener(NewFileName$, modetouse, Len(recordvar))
On Error Resume Next
For i = 1 To recordcount
Get filenum, i, recordvar
Put cleanupfilenum, i, recordvar
Next i
Close
Kill ExePath + "DOCMAN.DAT"
Name NewFileName$ As ExePath + "DOCMAN.DAT"
Exit Sub


cleanuperrs:
action = FileErrors(Err, NewFileName$)
Select Case action
Case 0
Resume
Case Else
End
Exit Sub
End Select

End Sub

Sub clearfields ()
OpenDM.Description.text = ""
OpenDM.Text1(0).text = ""
OpenDM.Text1(1).text = ""
OpenDM.Text1(2).text = ""
OpenDM.Text1(4).text = ""
OpenDM.Text1(5).text = ""
OpenDM.Text1(6).text = ""
OpenDM.Text1(7).text = ""
End Sub

Sub addkeys ()
 Finddlg.list1.AddItem OpenDM.Text1(4).text
 Finddlg.list1.AddItem OpenDM.Text1(5).text
 Finddlg.list1.AddItem OpenDM.Text1(6).text
 Finddlg.list1.AddItem OpenDM.Text1(7).text
 items = Finddlg.list1.listcount
 check = 0
 Finddlg.list1.Refresh
 NewKeys = 0
 Do While check < (items)
    If UCase$(RTrim$(Finddlg.list1.list(check))) <> UCase$(RTrim$(Finddlg.list1.list(check + 1))) And RTrim$(Finddlg.list1.list(check)) <> "" Then
        check = check + 1
        NewKeys = 1
    Else
        Finddlg.list1.RemoveItem check
        items = items - 1
    End If
    Loop

   If NewKeys = 0 Then Exit Sub
   WriteKeyFields
End Sub

Sub opendoc ()
screen.mousepointer = 11
getfile
If editfile = "" Then Exit Sub
Select Case Right$(editfile, 3)
Case "sam"
RunProg$ = "C:\amipro\amipro.exe "
AppName$ = "Ami Pro"
Case "smm"
RunProg$ = "C:\amipro\amipro.exe "
AppName$ = "Ami Pro"
Case Else
screen.mousepointer = 1: Exit Sub
End Select

If Not Loaded("Ami Pro") Then
X = Shell(RunProg$ + editfile, 2)
Arrange$ = "%WT"
Else
AppActivate (AppName$)
If IsIconic(LastWindowHandle) Then
X = PostMessage(LastWindowHandle, WM_SYSCOMMAND, SC_RESTORE, 0)
Arrange$ = "%WC"
End If
SendKeys "%FO" + editfile + "~", TRUE
End If
SendKeys Arrange$, TRUE
screen.mousepointer = 1
End Sub

Sub getfile ()
editfile = ""
editpath = ""
editfile = recordvar.file
length = Len(editfile)
For i = length To 0 Step -1
If Asc(Right$(editfile, 1)) < 33 Or Asc(Right$(editfile, 1)) > 122 Then editfile = Left$(editfile, i)
Next i
length = Len(editfile)
If length = 0 Then Exit Sub
End Sub

Function Loaded (Caption$)
    LastWindowHandle = FindWindow(0&, Caption$)
    If LastWindowHandle > 0 Then Loaded = -1
End Function

Sub WriteKeyFields ()
KEYSFILENUM = FreeFile
On Error GoTo unloaderror
keysfile$ = ExePath + "dmkeys.dat"
On Error Resume Next
Kill keysfile$
On Error GoTo unloaderror
Open keysfile$ For Output As KEYSFILENUM
items = Finddlg.list1.listcount
check = 0
Do While check < (items)
out$ = Finddlg.list1.list(check)
Print #KEYSFILENUM, out$
check = check + 1
Loop
Close KEYSFILENUM
Exit Sub

unloaderror:
action = FileErrors(Err, NewFileName$)
Select Case action
Case 0
Resume
Case Else
Exit Sub
End Select

End Sub

Sub GetPath ()
Const GCW_HMODULE = (-16)
ExePath = String$(127, 0)
X = GetModuleFilename(GetClassWord(OpenDM.Hwnd, GCW_HMODULE), ExePath, Len(ExePath))
X = Len(ExePath)
Do While X > 0
If Mid$(ExePath, X, 1) = "\" Then Exit Do
X = X - 1
Loop
If X = 0 Then
ExePath = "\"
Else ExePath = Left$(ExePath, X)
End If
End Sub

Sub PicFrame (F As Control, C As Control)
  Lft = C.Left - 20
  Tp = C.top - 20
  Ht = C.Height + 40
  Wdth = C.Width + 40
  Call BoxDraw(F, Tp, Lft, Ht, Wdth)
End Sub

Sub BoxDraw (F As Control, Tp As Integer, Lft As Integer, Ht As Integer, Wdth As Integer)
  Offset = 3
  BigOffset = 5
  DW = 2
  F.DrawWidth = DW

F.forecolor = &HE0E0E0
'bottom:
  F.Line (Lft + DW, Tp + Ht + Offset)-(Lft - DW + Wdth, Tp + Ht + Offset)

'right:
  F.Line (Lft + Wdth + Offset, Tp + DW)-(Lft + Wdth + Offset, Tp + Ht + Offset - DW)


  F.forecolor = &H808080
'top:
 F.Line (Lft + DW - BigOffset, Tp - BigOffset)-(Lft - DW + Wdth + BigOffset, Tp - BigOffset)

'left:
F.Line (Lft - BigOffset, Tp - BigOffset + DW)-(Lft - BigOffset, Tp + Ht + BigOffset - DW)


End Sub

Sub BoxDraw2 (F As Control, Tp As Integer, Lft As Integer, Ht As Integer, Wdth As Integer, DW As Integer)
  Offset = 3
  BigOffset = 5
  F.DrawWidth = DW

F.forecolor = &H808080
'bottom:
  F.Line (Lft + DW, Tp + Ht + Offset)-(Lft - DW + Wdth, Tp + Ht + Offset)

'right:
  F.Line (Lft + Wdth + Offset, Tp + DW)-(Lft + Wdth + Offset, Tp + Ht + Offset - DW)


  F.forecolor = &HE0E0E0
'top:
 F.Line (Lft + DW - BigOffset, Tp - BigOffset)-(Lft - DW + Wdth + BigOffset, Tp - BigOffset)

'left:
F.Line (Lft - BigOffset, Tp - BigOffset + DW)-(Lft - BigOffset, Tp + Ht + BigOffset - DW)


End Sub